unit CryptoApi;

interface

uses wincrypt,windows,sysutils;

function ImportPair(Path:String; Password:PChar; var RSA:HCRYPTPROV; var BothKeys:HCRYPTKEY):DWORD;
function ImportPub(pBuf:Pointer; var RSA:HCRYPTPROV; var PubKey:HCRYPTKEY):DWORD;
function GetRealOutputSize(Key:HCRYPTKEY;Size:DWORD):DWORD;
procedure EncryptBuf(Key:HCRYPTKEY;pBuf:Pointer;dwPlaintextLen:DWORD);
procedure DecryptBuf(Key:HCRYPTKEY;pBuf:Pointer;szBuf:DWORD);

implementation

function GetRealOutputSize(Key:HCRYPTKEY;Size:DWORD):DWORD;
var
  FullBlockLen:DWORD;
  RealBlockCapacity:DWORD;
  szDword:DWORD;
begin
  szDword:=SizeOf(RealBlockCapacity);
  if CryptGetKeyParam(Key,KP_BLOCKLEN,@FullBlockLen,@szDword,0) then
  begin
    FullBlockLen:=FullBlockLen div 8;
    RealBlockCapacity:=FullBlockLen - 11;
    Result:=(Size div RealBlockCapacity)*FullBlockLen;
    if BOOL(Size mod RealBlockCapacity) then
      Result:=Result+FullBlockLen;
  end
  else
    Result:=0;
end;

procedure Dump(P:Pointer; Size:DWORD; Capt:PChar);
var
  Str:PChar;
  I:Integer;
begin
  GetMem(Str,Size*2+4);
  lstrcpy(Str,'');
  for i:=0 to Size-1 do
    Str:=PChar(Str+IntToHex(PBYTE(DWORD(P)+i)^,2));
  MessageBoxA(0,PChar(Str),Capt,0);
  FreeMemory(Str);
end;

procedure EncryptBuf(Key:HCRYPTKEY;pBuf:Pointer;dwPlaintextLen:DWORD);
var
  InSize:DWORD;
  OutSize:DWORD;
  Size:DWORD;
  szDword:DWORD;
  szDoubleBuf:DWORD;
  Position:DWORD;
  BlockBuf:Pointer;
  DoubleBuf:Pointer;
  final:BOOL;
  i:Integer;
begin     
  if (Key=0) or (pBuf=nil) or (dwPlaintextLen=0) then exit;
  Position:=0;
  final:=false;

  szDword:=SizeOf(OutSize);
  CryptGetKeyParam(Key,KP_BLOCKLEN,@OutSize,@szDword,0);
  OutSize:=OutSize div 8;
  InSize:=OutSize-11;

  GetMem(BlockBuf,OutSize);
  szDoubleBuf:=GetRealOutputSize(Key,dwPlaintextLen);
  GetMem(DoubleBuf,szDoubleBuf);

  repeat
    if (Position+1)*InSize >= dwPlaintextLen then
    begin
      Size:=dwPlaintextLen-Position*InSize;
      final:=true;
    end
    else
      Size:=InSize;

    CopyMemory(BlockBuf,Pointer(DWORD(pBuf)+Position*InSize),Size);
    if Size<OutSize then
    begin
    {
      Initialisation
      In Pascal Version 7, Randomize initialises the longint RandSeed with a
      32-bit value derived by permuting values (H, M, S, C) from the DOS time.
      Previously thought to be from permuting the date and the time; could this
      have been another version of Pascal? The time has 55 ms resolution; be sure
      to consider whether this is adequate. There are only $1800B0 ticks per day
      (and fewer per working day), so the initial RandSeed cannot take all possible
      values of its type, by a factor of $100000000/$1800B0 ~ $AAA = 2730.

      In    Delphi, RandSeed is initialised differently (dependent on version).
      D3 (& D4, D6 apparently) uses milliseconds since midnight GMT, which would
      imply that the initial RandSeed cannot take all possible values of its type
      by a factor of $100000000/86400000 = $31 = 49. However, at least in my D3,
      the number of milliseconds is always divisible by 10, and evidently rises
      at 18.2 Hz; it must be derived from the DOS timer at $40:$6C, as for Pascal 7
      above. The factor is again ~2730.

      John Herbster reports : D7 code looks like this :-
              if QueryPerformanceCounter(Counter)
              then RandSeed := Counter //overflow checking off here
              else RandSeed := GetTickCount; //rollover in 49.5 days

      Turbo Delphi 2006 has the same code. Note that the increment of GetTickCount may not always be unity; see my Delphi Programming, and Win32 Help. Counter increments at CPU frequency.

      If RandSeed were to be initialised by the result of an RDTSC instruction,
      all values could be obtained on a system that didn't get rebooted too often.
      RDTSC gives 64 bits; maybe XOR the halves, and BSWAP.

      http://www.merlyn.demon.co.uk/pas-rand.htm
    }
      {
      for i:=Size to OutSize-1 do
        PByte(DWORD(BlockBuf)+i)^:=random(256);
      }
    end;

    //Dump(BlockBuf,OutSize,'encrypt1');
    CryptEncrypt(Key,0,final,0,BlockBuf,@Size,OutSize);
    //Dump(BlockBuf,OutSize,'encrypt2');
    CopyMemory(Pointer(DWORD(DoubleBuf)+Position*OutSize),BlockBuf,OutSize);
    Inc(Position);
  until final;

  FreeMem(BlockBuf);
  CopyMemory(pBuf,DoubleBuf,szDoubleBuf);
  FreeMem(DoubleBuf);
end;

procedure DecryptBuf(Key:HCRYPTKEY;pBuf:Pointer;szBuf:DWORD);
var       
  BlockSize:DWORD;
  BlockBuf:Pointer;
  szDword:DWORD;
  final:BOOL;
  PositionR:DWORD;
  PositionW:DWORD;
begin
  if (Key=0) or (pBuf=nil) or (szBuf=0) then exit;
  final:=false;
  PositionR:=0;
  PositionW:=0;

  szDword:=SizeOf(BlockSize);
  CryptGetKeyParam(Key,KP_BLOCKLEN,@BlockSize,@szDword,0);
  BlockSize:=BlockSize div 8;
  GetMem(BlockBuf,BlockSize);

  repeat
    if PositionR+BlockSize >= szBuf then
    begin
      szDword:=szBuf-PositionR;
      final:=true;
    end
    else
      szDword:=BlockSize;
      
    CopyMemory(BlockBuf,Pointer(DWORD(pBuf)+PositionR),BlockSize);
    CryptDecrypt(key,0,final,0,BlockBuf,@szDword);
    CopyMemory(Pointer(DWORD(pBuf)+PositionW),BlockBuf,szDword);

    PositionR:=PositionR+BlockSize;
    PositionW:=PositionW+szDword;
  until final;

  FreeMem(BlockBuf);
end;

function ImportPub(pBuf:Pointer; var RSA:HCRYPTPROV; var PubKey:HCRYPTKEY):DWORD;
var
  F:File;
  FSize:DWORD;

  bRes:BOOL;
begin
  while true do
  begin
    if pBuf=nil then break;

    bRes:=CryptAcquireContext(
          @RSA,                 // returned crypto-provider handle.
          nil,                  // use default key container.
          nil,                  // use default CSP (Cryptographic Service Provider).
          PROV_RSA_FULL,        // MS RSA provider (presents by default).
          0                     // no special action.
      );
    if GetLastError=Cardinal(NTE_BAD_KEYSET) then
    bRes:=CryptAcquireContext(
          @RSA,
          nil,
          nil,
          PROV_RSA_FULL,
          CRYPT_NEWKEYSET       // make new keyset
      );
    if not bRes then Break;

    bRes:=CryptImportKey(RSA,pBuf,FSize,0,0,@PubKey);
    if not bRes then Break;

    Result:=0;
    //FreeMemory(pBuf);
    exit;
  end;
  Result:=GetLastError;
  //FreeMemory(pBuf);
end;

function ImportPair(Path:String; Password:PChar; var RSA:HCRYPTPROV; var BothKeys:HCRYPTKEY):DWORD;
var
  F:File;
  FSize:DWORD;
  Buf:Pointer;


  Hash:HCRYPTHASH;
  expKey:HCRYPTKEY;

  bRes:BOOL;
begin
  while true do
  begin
    if (not FileExists(Path)) or (lstrlen(Password)=0)  then break;

    AssignFile(F,Path);
    Reset(F,1);
    FSize:=FileSize(F);
    Buf:=GetMemory(FSize);
    BlockRead(F,Buf^,FSize);
    CloseFile(F);

    bRes:=CryptAcquireContext(
          @RSA,                 // returned crypto-provider handle.
          nil,                  // use default key container.
          nil,                  // use default CSP (Cryptographic Service Provider).
          PROV_RSA_FULL,        // MS RSA provider (presents by default).
          0                     // no special action.
      );
    if GetLastError=Cardinal(NTE_BAD_KEYSET) then
    bRes:=CryptAcquireContext(
          @RSA,
          nil,
          nil,
          PROV_RSA_FULL,
          CRYPT_NEWKEYSET       // make new keyset
      );
    if not bRes then Break;

    bRes:=CryptCreateHash(RSA,CALG_SHA,0,0,@Hash);
    if not bRes then Break;

    bRes:=CryptHashData(Hash,PByte(Password),lstrlen(Password),0);
    if not bRes then Break;

    bRes:=CryptDeriveKey(RSA,CALG_RC4,Hash,0{CRYPT_EXPORTABLE},@expKey);
    if not bRes then Break;

    //CryptSetKeyParam(expKey,KP_MODE,@Param,0); what?

    CryptDestroyHash(Hash);

    bRes:=CryptImportKey(RSA,Buf,FSize,expKey,0,@BothKeys);
    if not bRes then Break;

    Result:=0;
    FreeMemory(Buf);
    exit;
  end;
  Result:=GetLastError;
  FreeMemory(Buf);

  CryptDestroyKey(expKey);
end;

end.
